home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl1615.lha / misc / cstruct.lsp next >
Lisp/Scheme  |  1991-03-18  |  5KB  |  158 lines
  1. ;; Sample usage:  Create lisp defstructs corresponding to C structures:
  2. (use-package "SLOOP")
  3. ;; How to: Create a file foo.c which contains just structures
  4. ;; and possibly some externs.   
  5. ;; cc -E /tmp/foo1.c  > /tmp/fo2.c
  6. ;; ../xbin/strip-ifdef /tmp/fo2.c > /tmp/fo3.c
  7. ;; then (parse-file "/tmp/fo3.c")
  8. ;; will return a list of defstructs and appropriate slot offsets.
  9.  
  10.  
  11. (defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline  #\tab)))
  12.  
  13. (defvar *eof* (code-char 255))
  14. (defun delimiter(ch) (or (white-space ch)
  15.              (member ch '(#\, #\;  #\{ #\} #\*))))
  16. (defun next-char (st)
  17.   (let ((char (read-char st nil *eof*)))
  18.     
  19.     (case char
  20.       (#\{  char)
  21.       (
  22.        #\/ (cond ((eql (peek-char nil st nil) #\*)
  23.           (read-char st)
  24.           (sloop when (eql (read-char st) #\*)
  25.             do (cond ((eql (read-char st) #\/ )
  26.                   (return-from next-char (next-char st))))))
  27.         (t char)))
  28.       ((#\tab #\linefeed #\return #\newline )
  29.        (cond ((member (peek-char nil st nil) '(#\space #\tab #\linefeed #\return #\newline  ))
  30.           (return-from next-char (next-char st))))
  31.        #\space)
  32.       (t char))))
  33.  
  34. (defun get-token (st &aux tem)
  35.   (sloop while (white-space (peek-char nil st nil))
  36.      do (read-char st))
  37.   (cond ((member (setq tem (peek-char nil st nil)) '(#\, #\; #\* #\{ #\} ))
  38.      (return-from get-token (coerce (list (next-char st)) 'string))))
  39.   (sloop with x = (make-array 10 :element-type 'character  :fill-pointer 0
  40.                   :adjustable t)
  41.     when  (delimiter (setq tem (next-char st)))
  42.     do (cond ((> (length x) 0)
  43.           (or (white-space tem) (unread-char tem st))
  44.           (return x)))
  45.     else
  46.     do
  47.     (cond ((eql tem *eof*) (return *eof*))
  48.       (t    (vector-push-extend tem x)))))
  49. (defvar *parse-list* nil)
  50. (defvar *structs* nil)
  51. (defun parse-file (fi &optional *structs*)
  52.   (with-open-file (st fi)
  53.     (let ((*parse-list*
  54.       (sloop while (not (eql *eof* (setq tem (get-token st))))
  55.          collect  (intern tem))))
  56.       (print *parse-list*)
  57.       (let ((structs
  58.          (sloop while (setq tem (parse-struct))
  59.             do (push tem *structs*)
  60.             collect tem)))
  61.     (get-sizes fi structs)
  62.     (with-open-file (st "gaz3.lsp")
  63.       (prog1 
  64.       (list structs (read st))
  65.       (delete-file "gaz3.lsp")))))))
  66.       
  67.  
  68.   
  69.  
  70.  
  71. (defparameter *type-alist* '((|short| . signed-short)
  72.                (|unsigned short| . unsigned-short)
  73.                (|char| . signed-char)
  74.                (|unsigned char| . unsigned-char)
  75.                (|int| . fixnum)
  76.                (|long| . fixnum)
  77.                (|object| . t)))
  78.  
  79.  
  80. (defun parse-type( &aux top)
  81.    (setq top (pop *parse-list*))
  82.   (cond ((member top '(|unsigned| |signed|))
  83.      (push (intern (format nil "~a-~a" (pop *parse-list*))) *parse-list*)
  84.      (parse-type))
  85.     ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum)
  86.     ((eq top '|struct|)
  87.      (prog1
  88.          (cond ((car (member (car *parse-list*)  *STRUCTS* :key 'cadr)))
  89.            (t (error "unknown struct ~a " (car *parse-list*))))
  90.        (pop *parse-list*)
  91.        ))
  92.     ((cdr (assoc top *type-alist*)))
  93.     (t (error "unknown type ~a " top))))
  94. (defun expect (x) (or (eql (car *parse-list*) x)
  95.               (error "expected ~a at beginning of ~s" x *parse-list*))
  96.   (pop *parse-list*))
  97. (defun parse-field ( &aux tem)
  98.   (cond ((eql (car *parse-list*) '|}|)
  99.      (pop *parse-list*)
  100.      (expect '|;|)
  101.      nil)
  102.     (t
  103.     (let ((type (parse-type)))
  104.       
  105.       (sloop until (eql (setq tem (pop *parse-list*)) '|;|)
  106.          append (get-field tem type)
  107.              
  108.          do (or (eq (car *parse-list*) '|;|) (expect '|,|)))))))
  109. (deftype pointer () `(integer ,most-negative-fixnum most-positive-fixnum))
  110. (defun get-field (name type)
  111.   (cond ((eq name '|*|)(get-field (pop *parse-list*) 'pointer))
  112.     ((and (consp type) (eq (car type) 'defstruct))
  113.      (sloop for w in (cddr type)
  114.         append (get-field
  115.              (intern (format nil "~a.~a" name (car w)))
  116.              (fourth w))))
  117.     (t 
  118.      `((,name ,(if (eq type t) nil 0) :type ,type)))))
  119.  
  120. (defun parse-struct ()
  121.   (cond ((null *parse-list*) (return-from parse-struct nil)))
  122.   (cond ((not (eq (car *parse-list*) '|struct|))
  123.      (sloop until (eq (pop *parse-list*) '|;|))
  124.      (return-from parse-struct (parse-struct))))
  125.   (expect '|struct|)
  126.   (let* ((name (prog1 (pop *parse-list*)(expect '|{|))))
  127.     `(defstruct ,name ,@
  128.            (sloop while (setq tem (parse-field))
  129.        append tem))))
  130.  
  131. (defun printf (st x &rest y)
  132.   (format st "~%printf(\"~a\"" x)
  133.   (sloop for w in y do (princ "," st) (princ y st))
  134.   (princ ");" st))
  135.  
  136. (defun get-sizes (file structs)
  137.   (with-open-file (st "gaz0" :direction :output)
  138.     (sloop for i from 1
  139.        for u in structs
  140.        do (format st "struct ~a SSS~a;~%" (second u) i))
  141.     (format st "~%main() {~%")
  142.     (printf st "(")
  143.     (sloop for i from 1
  144.        for u in structs
  145.        do
  146.        (printf st (format nil "(|~a| " (second u)))
  147.        (sloop for w in (cddr u)
  148.           do
  149.           (printf st " %d "
  150.               (format nil "(char *)&SSS~a.~a - (char *)&SSS~a"
  151.                   i (car w) i)))
  152.        (printf st ")"))
  153.     (printf st ")")
  154.     (princ " ;}" st))
  155.   (system
  156.    (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (tmpx > gaz3.lsp) ; rm -f  gaz0" file)))
  157.  
  158.